home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #45 (Jun 89) / Forth Code / Beeper INIT next >
Text File  |  1989-04-17  |  5KB  |  201 lines
  1. \ INIT example which patches _GetResource 
  2. \ with a call to _Sysbeep if type=CODE id=0
  3. \ Also patches _ExitToShell, using an absolutely
  4. \ AWFUL hack, but a _SetTrapAddress patch
  5. \ seems to be removed under Multifinder
  6. \ J. Langowski / MacTutor April 1989
  7.  
  8. only forth also mac also assembler
  9.  
  10. ( *** compiler support words for external definitions *** )
  11. : :xdef 
  12.     create     -4 allot
  13.         $4EFA w, ( JMP )
  14.         0 w,     ( entry point to be filled later )
  15.         0 ,      ( length of routine to be filled later )
  16.         here 6 - 76543
  17. ;
  18.  
  19. : ;xdef { branch marker entry | -- }
  20.     marker 76543 <> abort" xdef mismatch"
  21.     entry branch - branch w!
  22.     here branch - 2+ branch 2+ !
  23. ; 
  24.     
  25. : xlen 4 + @ ; ( get length word of external definition )
  26.  
  27. \ **** ext procedure glue macros
  28.  
  29. CODE ext.prelude
  30.     LINK    A6,#-700             ( 700 bytes of local Forth stack )
  31.     MOVEM.L A0-A5/D0-D7,-(A7)        ( save registers )
  32.     MOVE.L A6,A3                ( setup local loop return stack )
  33.     SUBA.L #500,A3                ( in the low 200 local stack bytes )
  34.     RTS            \ just to indicate the MACHro stops here 
  35. END-CODE MACH
  36.  
  37. CODE ext.epilogue
  38.     MOVEM.L (A7)+,A0-A5/D0-D7    ( restore registers )
  39.     UNLK    A6
  40.     RTS
  41. END-CODE MACH
  42.  
  43. .trap    _newPtr,SYS    $A51E
  44.  
  45. -4         CONSTANT     thePort
  46. $904     CONSTANT     CurrentA5
  47. $A9A0    CONSTANT    tGetRes    \ GetResource
  48. $A9F4    CONSTANT    tExit    \ ExitToShell
  49.  
  50. \ |--------------------------------|
  51. \ | INIT resource code starts here |
  52. \ |--------------------------------|
  53.  
  54. :xdef beeperINIT
  55.  
  56. header PatchStart
  57. header oldGetRes
  58.     DC.L 0
  59. header oldExit
  60.     DC.L 0
  61.  
  62. : GetResPatch
  63.     ext.prelude
  64.     CLR.L    D0
  65.     MOVE.W    8(A6),D0
  66.     MOVE.L    10(A6),D1
  67.     MOVE.L    D0,-(A6)
  68.     MOVE.L    D1,-(A6)
  69.  
  70. \ main FORTH code starts here
  71. \ this can be used to log any launch
  72. \ (i.e. GetResource CODE 0 ) to a log file
  73. \ which has to be created/opened by the INIT code
  74.  
  75.     ascii CODE = swap 0= and IF
  76.         \    (call) debugger
  77.             1 (call) sysbeep
  78.     THEN
  79. \ end of main code
  80.  
  81.     ext.epilogue
  82.     LEA        oldGetRes,A0
  83.     MOVE.L    (A0),A0
  84.     JMP        (A0) 
  85. ;
  86.  
  87. : ExitPatch
  88.     ext.prelude
  89.  
  90. \ main FORTH code starts here
  91. \ this can eventually be used to write a line to 
  92. \ the same log file as before
  93.     \        (call) debugger
  94.             1 (call) sysbeep
  95. \ end of main code
  96.  
  97.     ext.epilogue
  98.     LEA        oldExit,A0
  99.     MOVE.L    (A0),A0
  100.     JMP        (A0) 
  101. ;
  102.  
  103. header PatchEnd
  104.  
  105. : movePatch { | length -- patch }
  106.     ['] patchEnd ['] PatchStart -   -> length
  107.     length
  108.     MOVE.L (A6)+,D0
  109.     _newPtr,sys
  110.     MOVE.L A0,-(A6)
  111.     dup IF ( we have space in system heap )
  112.         ['] PatchStart over length swap (call) blockMove drop
  113.     THEN
  114. ;
  115.         
  116. : myINIT { | patch pExit -- }
  117.     movePatch -> patch
  118.     patch IF
  119.         \ patch _GetResource
  120.         tGetRes (call) GetTrapAddress
  121.         patch !        \  old GetResource
  122.         ['] GetResPatch ['] PatchStart -
  123.         patch + tGetRes (call) SetTrapAddress
  124.         " GetResource patch has been installed." 0 0 0 (call) ParamText
  125.         1000 0 (call) NoteAlert drop
  126.  
  127.         \ patch _ExitToShell, using hack
  128.         tExit (call) GetTrapAddress -> pExit
  129.         pExit w@ $4EF9 = 
  130.         IF \ is it a JMP ? we're probably in Multifinder...
  131.             pExit 2+ @
  132.             patch 4+ !    \  old ExitToShell
  133.             ['] ExitPatch ['] PatchStart -
  134.             patch + pExit 2+ ! 
  135.                 \ patch directly into Juggler's innards. BOO!
  136.             " ExitToShell patch in Multifinder." 0 0 0 (call) ParamText
  137.             1000 0 (call) NoteAlert drop
  138.         ELSE
  139.             pExit patch 4+ !
  140.             ['] ExitPatch ['] PatchStart -
  141.             patch + tExit (call) SetTrapAddress
  142.             " ExitToShell patch in Finder." 0 0 0 (call) ParamText
  143.             1000 0 (call) NoteAlert drop
  144.         THEN
  145.     ELSE
  146.         " Can't get memory for patches." 0 0 0 (call) ParamText
  147.         1000 0 (call) NoteAlert drop
  148.     THEN
  149. ;
  150.  
  151. : INITrun { | newA5 myGlobals [ 202 lallot ] theHandle -- } 
  152. \    (call) debugger 
  153.     ['] beeperINIT (call) recoverHandle -> theHandle
  154.     theHandle (call) Hlock drop
  155.     ^ newA5
  156.     MOVE.L    (A6)+,A5        \ create area for QD globals
  157.     MOVE.L    A5,CurrentA5    \ A5 points to it
  158.     ^ newA5 thePort + (call) InitGraf
  159.     (call) InitFonts
  160.     (call) InitWindows
  161.     (call) TEInit
  162.     0 (call) InitDialogs
  163.     (call) InitCursor
  164.  
  165.     myINIT    \ call main INIT routine
  166.  
  167.     theHandle (call) HUnLock drop
  168.     theHandle (call) DisposHandle drop
  169. ;
  170.  
  171. : gINIT
  172.     ext.prelude INITrun    ext.epilogue
  173.     MOVE.L    A5,CurrentA5    
  174. ;
  175.  
  176. ' gINIT ;xdef
  177.  
  178. ( *** creating the INIT file *** )
  179. : $create-res call CreateResFile call ResError L_ext ;
  180.  
  181. : $open-res { addr | refNum -- result }
  182.     addr call openresfile -> refNum
  183.     call ResError L_ext
  184.     dup not IF drop refNum THEN 
  185. ;
  186.  
  187. : $close-res call CloseResFile call ResError L_ext ;
  188.  
  189. : make-init { | refNum -- }
  190.     " theINIT" dup $create-res drop
  191.     $open-res dup -> refNum call UseResFile 
  192.     ascii INIT 12 call GetResource 
  193.         ?dup IF call RmveResource THEN
  194.     ['] beeperINIT dup xlen
  195.         call PtrToHand drop ( result code )
  196.         ascii INIT 12 call GetResource 
  197.             ?dup IF call RmveResource THEN
  198.         ascii INIT 12 " Beeper" call AddResource
  199.     refNum $close-res drop ( result code )
  200. ;
  201.